home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / SCHEME / GNU / SCM4E1 / !Scm / scm / arc_demos next >
Text File  |  1994-06-19  |  5KB  |  218 lines
  1. ;
  2. ; Scheme demo code for new archi routines - Al Slater 9/6/94->
  3. ; Note - if you come up with any really nice routines - I'll include em
  4. ; with credits ...
  5. ;
  6.  
  7. ;
  8. ; Utility functions
  9. ;
  10. (define Xscreen 1280)          ;; physical size
  11. (define Yscreen 1024)          ;; ditto
  12. (define Left   -10)
  13. (define Right  10)
  14. (define Top    10)
  15. (define Bottom -10)
  16.  
  17. (define i->e inexact->exact)  ;; saves typing.
  18.  
  19. ; 
  20. ; Set-universal-point => given two floating point values plot them.
  21. ;
  22. (define (sup xw yw)
  23.       (point
  24.           (i->e (round (/ (* (- xw Left) Xscreen) (- Right Left))))
  25.           (i->e (round (/ (* (- yw Bottom) Yscreen) (- Top Bottom))))
  26.       )
  27. )
  28.  
  29. ; ---------------------------------------------------------------------------
  30. ;; martin maps - run by (martin-map) - hit escape when you are bored.
  31. ;; note it'll run out of memory eventually if you leave it long enough,
  32. ;; but by that time you'll have seen more than enough.
  33.  
  34.  
  35. (define a 3.1)                          ;; something around Pi works ok..
  36.  
  37. (define (martin-iter x y)
  38. (let ((newx (- y (sin x)))(newy (- a x)))
  39.       (begin
  40.       (sup newx newy)
  41.       `(,newx ,newy))))    ;;; note use of backquote...
  42.  
  43. ;
  44. ; Prize for doing this more tidily - overwriting your own arguments is 
  45. ; absolutely bletcherous...(as well as being the most dire example of how not
  46. ; to do functional programming)
  47. ;
  48. (define (mm x y)
  49. (begin
  50.       (define res (martin-iter x y))
  51.       (set! x (car res))
  52.       (set! y (cadr res))
  53.       (mm x y)
  54. ))
  55.  
  56. (define (martin-map)
  57. (begin
  58.       (mode 12)
  59.       (gcol 0 1)
  60.       ;
  61.       ; ALWAYS define these four somewhere in your gfx routines if using
  62.       ; set-universal-point (and use set! NOT define..) confused yet?
  63.       ;
  64.       (set! Left          -10)
  65.       (set! Right          10)
  66.       (set! Top          10)
  67.       (set! Bottom      -10)
  68.       (mm 0 0)
  69. ))
  70.  
  71. ; ---------------------------------------------------------------------------
  72. ; A curve or two
  73.  
  74. (define pi 3.14159)
  75.  
  76. ; degrees -> radians
  77. (define (d->r a)(* a (/ pi 180)))
  78.  
  79. (define (iterate f from to expr)
  80. (if (> from to)
  81.       'done
  82.       (begin
  83.               (expr f from to)
  84.               (iterate f (+ from 1) to expr))))
  85.  
  86. (define (p-f f x y)
  87. (let ((fx (f (d->r x))))
  88.       (sup x fx)))
  89.  
  90. (define (f-curve f)
  91.       (begin
  92.               (mode 12)
  93.               (iterate f Left Right p-f)
  94.               (get)))
  95.  
  96. (define (trig-curve f)
  97. (begin 
  98.       (set! Left          0)
  99.       (set! Right          720)
  100.       (set! Top          2)
  101.       (set! Bottom      -2)
  102.       (f-curve f)
  103.       (get)))
  104.  
  105. (define (sin-curve)(trig-curve sin))
  106. (define (cos-curve)(trig-curve cos))
  107.  
  108. (define (tan-curve)
  109. (begin
  110.       (set! Left          0)
  111.       (set! Right          360)
  112.       (set! Top          10)
  113.       (set! Bottom        -10)
  114.       (f-curve tan)
  115.       (get)
  116. ))
  117.  
  118. ; ---------------------------------------------------------------------------
  119. ; Henon attractor
  120. ; try (henon) and hit escape when you've seen enough.
  121.  
  122. (define h_a 1.4)
  123. (define h_b 0.3)
  124.  
  125. (define (h_s i) (i->e (+ 400 (* 300 i))))
  126.  
  127. (define (henon-attractor x y)
  128. (begin
  129.       (point (h_s y)(h_s x))  ;; i prefer it this way around...
  130.       (define xn x)
  131.       (define newx (+ (- y (+ (* h_a x x))) 1))
  132.       (define newy (* h_b xn))    
  133.       (henon-attractor newx newy)))
  134.  
  135. (define (henon)
  136. (begin
  137.       (mode 12)
  138.       (gcol 0 1)
  139.       (henon-attractor 0 0)))
  140.      
  141. ; ---------------------------------------------------------------------------
  142. ; Ikeda attractor (from Pickover)
  143. ; Horrendously space inefficient no doubt....
  144.  
  145. (define ia_c1 0.4)
  146. (define ia_c2 0.9)
  147. (define ia_c3 6.0)
  148. (define ia_rho 1.0)
  149. (define ia_scale 200)
  150. (define ia_xoff  600)
  151. (define ia_yoff  500)
  152.  
  153. (define (ikeda-iter i x y)
  154. (if (> i 3000)
  155.     'done
  156.     (begin
  157.           (define temp (/ (- ia_c1 ia_c3) (+ 1 (* x x) (* y y))))
  158.           (define sin_temp (sin temp))
  159.           (define cos_temp (cos temp))
  160.           (define xt (+ ia_rho (* ia_c2 (- (* x cos_temp) (* y sin_temp)))))
  161.           (define newy (* ia_c2 (+ (* x sin_temp)(* y cos_temp))))
  162.           (define newx xt)
  163.           (point (i->e (+ (* x ia_scale) ia_xoff))
  164.                  (i->e (+ (* y ia_scale) ia_yoff)))
  165.           (ikeda-iter (+ i 1) newx newy))))
  166.  
  167. (define (ikeda)
  168. (begin
  169.       (mode 12)
  170.       (ikeda-iter 1 0.1 0.1)))
  171.       
  172. ; ---------------------------------------------------------------------------
  173.  
  174.           
  175. ; ---------------------------------------------------------------------------
  176. ; Miscellaneous FP related definitions - see suggested things to try with
  177. ; definitions.
  178.  
  179. ;; like a 'for' loop
  180. ; try with
  181. ; (define (f n w)(+ 1 w))
  182. ; (itn 1 10 0 f)
  183. ; function 'f' is always defined in terms of 'n' and 'w' generally..
  184.  
  185. (define (itn n b w f)
  186.     (if (> n b)
  187.         w
  188.         (itn (+ n 1) b (f n w) f)
  189. ))
  190.  
  191. ;; itl (like foldl in miranda / itl in KRC)
  192. (define (itl l w f)
  193.     (if (null? l)
  194.         w
  195.         (itl (cdr l) (f (car l) w) f)
  196.     ))
  197.  
  198. ;; lit (like foldr in miranda / lit in KRC (this isn't strictly correct but
  199. ;; it'll do.)
  200. (define (lit f w l)
  201.     (if (null? l)
  202.         w
  203.         (f (car l) (lit f w (cdr l)))
  204.     ))
  205.  
  206. ;
  207. ; things to try with itl and lit :
  208. ; (itl '(1 2 3 4) '() cons)
  209. ; (lit cons '() '(1 2 3 4))
  210.  
  211. ; stuff thats nice to have defined..
  212. (define (go)
  213. (begin
  214.       (mode 12)
  215.       (graphics-origin! 640 512)
  216. ))
  217.  
  218. (display "Loaded Arc demos")(newline)